Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d1/filecat.arc/FMAIN01.INC

Text File | 1986-05-14 | 14.3 KB | 515 lines

VAR
  INT24Err: Boolean;
  INT24ErrCode: Byte;
  OldINT24: Array [1..2] Of Integer;

Procedure INT24;
  Begin
    Inline
     ($2E/$C6/$06/ INT24Err /$01/$89/$EC/$83/$C4/$08/$89/$F8/$2E/$A2/
      INT24ErrCode /$58/$B0/$FF/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07/$CF);
    { Turbo:  PUSH BP                    (Save caller's stack frame
              MOV  BP,SP                   Set up this procedure's stack frame
              PUSH BP                     ?)
      Inline: MOV  BYTE CS:[INT24Err],1  Set INT24Err to True
              MOV  SP,BP                 Get correct SP;  ADD: Discard saved
              ADD  SP,8                    BP, INT 24 return address & flags
              MOV  AX,DI                 Get INT 24 error code
              MOV  CS:[INT24ErrCode],AL  Save it in INT24ErrCode
              POP  AX                    Pop all registers
              MOV  AL,0FFH               Set FCB call error flag:
              POP  BX                      will cause Turbo I/O error on file
              POP  CX                      operations, no error on character
              POP  DX                      operations
              POP  SI
              POP  DI
              POP  BP
              POP  DS
              POP  ES
              IRET                       Return to next instruction }
  End;

Procedure INT24On;
  Begin
    INT24Err:=False;
    With Regs Do
     Begin
      AX:=$3524;
      MsDos(Regs);
      If (OldINT24[1] Or OldINT24[2])=0 Then
       Begin
        OldINT24[1]:=ES;
        OldINT24[2]:=BX;
       End;
      DS:=CSeg;
      DX:=Ofs(INT24);
      AX:=$2524;
      MsDos(Regs);
     End;
  End;

Procedure INT24Off;
  Begin
    INT24Err:=False;
    If OldINT24[1]<>0 Then
      With Regs Do
       Begin
        DS:=OldINT24[1];
        DX:=OldINT24[2];
        AX:=$2524;
        MsDos(Regs);
       End;
    OldINT24[1]:=0;
    OldINT24[2]:=0;
  End;

Function INT24Result: Integer;
  VAR I:Integer;
  Begin
    I:=IOResult;
    If INT24Err Then
     Begin
      I:=I+256*INT24ErrCode;
      INT24On;
     End;
    INT24Result:=I;
  End;

FUNCTION CheckDOSVersion:Str3;
  VAR S,S1:Str3;
  Begin
    Regs.AX := $3000;       { Func.Call $30 (Get DOS Version Number) }
    MsDos(Regs);
    Str(Regs.AL,S);
    Str(Regs.AH,S1);
    CheckDOSVersion:=S+'.'+S1;
    If NOT (S[1] in ['2','3']) then begin
      ClrScr;
      Write(^G);
      GotoXY(10,17);
      WriteLn('Sorry...  FILECAT requires DOS 2.X or greater.');
      Halt;
    End;
  End; { function CheckDOSVersion }

FUNCTION ConstStr(C:Char; N:Integer) : Str80;
  VAR S : String[80];
  Begin
    If N<0 then N:=0;
    S[0] := Chr(N);
    FillChar(S[1],N,C);
    ConstStr := S;
  End;

FUNCTION PrTest: Boolean;
  VAR I : Integer;
  Begin
    Regs.ax:=$0200;
    Regs.dx:=$0000;
    Intr($17,Regs);
    I := ((regs.ax and $FF00) shr 8);
    If (I=144) then PrTest := True
      Else PrTest := False;
  End; { function PrTest }

FUNCTION MonitorType : Integer;
  Begin
    MonitorType := Mem[$0040:$0049];
  End; { function MonitorType }

PROCEDURE HideCursor;
  Begin
    Inline($B9/$0F00/$B4/$01/$CD/$10);
  End; { procedure HideCursor }

PROCEDURE RestoreCursor;
  Begin
    If MonitorType = 7 then                  { Mono }
      Inline($B9/$0C0D/$B4/$01/$CD/$10)
    Else Inline($B9/$0607/$B4/$01/$CD/$10);  { CGA }
  End; { procedure RestoreCursor }

PROCEDURE Beep;
  Begin
    Sound(660);Delay(60);
    Sound(440);Delay(60);
    Sound(660);Delay(60);
    Sound(440);Delay(60);
    NoSound;
  End;

FUNCTION Yes: Boolean;
  VAR Ch:Char;
  Begin
    Repeat
      Read(Kbd,Ch);
      Ch:=UpCase(Ch);
      If Not (Ch in ['Y','N']) then Beep;
    Until Ch in ['Y','N'];
    Yes := (Ch='Y');
  End; { function Yes }

PROCEDURE DrawBox (Left, Right, Top, Bottom : Integer);
  VAR
   Index : Integer;
  Begin
    HideCursor;
    GotoXY(Left,Top);
    Write('┌');
    For Index := Left+1 to Right-1 DO Begin
      Write('─');
    End;
    Write('┐');
    For Index := Top+1 to Bottom-1 Do Begin
      GotoXY(Left,Index);
      Write('│');
      GotoXY(Right,Index);
      Write('│');
    End;
    GotoXY(Left,Bottom);
    Write('└');
    For Index := Left+1 to Right-1 Do Begin
      Write('─');
    End;
    Write('┘');
    RestoreCursor;
  End;

FUNCTION DOSDate:Str8;
  TYPE
    regpack = record
                ax,bx,cx,dx,bp,si,ds,es,flags: integer;
              end;
  VAR
    recpack:       regpack;                {record for MsDos call}
    month,day:     string[2];
    year:          string[4];
  begin
    with recpack do
    begin
      ax := $2a shl 8;
    end;
    MsDos(recpack);                        { call function }
    with recpack do
    begin
      str(cx,year);                        {convert to string}
      str(dx mod 256,day);                     { " }
      str(dx shr 8,month);                     { " }
    end;
    Year:=Copy(Year,3,2);
    If Length(Day) = 1 then Day:='0'+Day;
    DOSdate := month + '/' + day + '/' + year  ;
  end;

FUNCTION Freespace:real;
  VAR  fr : real;
  Begin
    with regs do
    begin
      dx := 0;
      ah := $36;
      MsDos(regs);
      fr := bx;
      if ax <> $FFFF then Freespace := fr * ax * cx else Freespace := 0
    End;
  End;  { function Freespace }

PROCEDURE SetDTA3;
  Begin
    Regs.AX := $1A00;       { Func.Call $1A (Set DTA) }
    Regs.DS := Seg(DTA3);
    Regs.DX := Ofs(DTA3);
    MsDos(Regs);
  End; { procedure SetDTA3 }

PROCEDURE SetASCIIZ(FName:Name);
  VAR I:Integer;
  Begin
    FillChar(ASCIIZ,SizeOf(ASCIIZ),0);
    For I:=1 to Length(FName) do ASCIIZ[I]:=FName[I];
  End; { procedure SetASCIIZ }

PROCEDURE FindFirst3(Att:Integer);
  Begin
    SetDTA3;
    Regs.AX := $4E00;       { Func.Call $4E (Find First) }
    Regs.DS := Seg(ASCIIZ);
    Regs.DX := Ofs(ASCIIZ);
    Regs.CX := Att;
    MsDos(Regs);
    Error:=Regs.AX;
  End; { procedure FindFirst3 }

PROCEDURE FindNext3;
  Begin
    SetDTA3;
    Regs.AX := $4F00;       { Func.Call $4F (Find Next) }
    Regs.DS := Seg(ASCIIZ);
    Regs.DX := Ofs(ASCIIZ);
    MsDos(Regs);
    Error:=Regs.AX;
  End; { procedure FindNext3 }

PROCEDURE GetName3;
  VAR
    I:Integer;
    S,S1:String[15];
    Name:Array[1..13] of Char;
  Begin
    S:=#0;
    S1:='';
    For I:=31 to 43 do Name[I-30]:=DTA3[I];
    For I:=31 to 30+Pos(S,Name) do S1:=S1+DTA3[I];
    I:=Pos('.',S1);
    Entry[EntryNum].EStatus:=0;
    If I=0 then Entry[EntryNum].EName:=S1
      Else begin
        Entry[EntryNum].EName:=Copy(S1,1,I-1);
        Entry[EntryNum].EExt:=Copy(S1,I+1,3);
      End;
    S:=Entry[EntryNum].EName;
    S:=S+ConstStr(' ',8-Length(S));
    Entry[EntryNum].EName:=S;
    S:=Entry[EntryNum].EExt;
    S:=S+ConstStr(' ',3-Length(S));
    Entry[EntryNum].EExt:=S;
    Entry[EntryNum].ETime:=Ord(DTA3[24]);
    Entry[EntryNum].ETime:=Entry[EntryNum].ETime shl 8;
    Entry[EntryNum].ETime:=Entry[EntryNum].ETime or Ord(DTA3[23]);
    Entry[EntryNum].EDate:=Ord(DTA3[26]);
    Entry[EntryNum].EDate:=Entry[EntryNum].EDate shl 8;
    Entry[EntryNum].EDate:=Entry[EntryNum].EDate or Ord(DTA3[25]);
    For I:=1 to 4 do Entry[EntryNum].ESize[I]:=Ord(DTA3[I+26]);
  End; { procedure GetName3 }

PROCEDURE BuildArray;
  VAR I:Integer;
  Begin
    INT24On;
    {$I-}
    ChDir(SourceDirectory);
    {$I+}
    I:=INT24Result;
    INT24Off;
    If I<>0 then Begin
      Beep;
    End;
    EntryNum:=0;
    FillChar(Entry,SizeOf(Entry),0);
    SetASCIIZ('*.*');
    FindFirst3(0);
    If Error=0 then begin
      EntryNum:=EntryNum+1;
      GetName3;
    End;
    If Error=0 then begin
      Repeat
      FindNext3;
      If (Error=0) and (EntryNum<250) then begin
        EntryNum:=EntryNum+1;
        GetName3;
      End;
      Until Error<>0;
    End;
  End; { procedure BuildArray }

PROCEDURE DisplayID;
  Procedure Center(R:Integer;D:Str80);
    Begin
      GotoXY((80 -Length(D)) div 2,R);
      Write(D);
    End;
  Begin
    ClrScr;
    DrawBox(10,70,1,6);
    HideCursor;
    Center(2,'FILECAT.COM -- A FILE CATALOGING UTILITY  V2.2');
    Center(3,'----------');
    LowVideo;
    Center(4,'Program written by Kenn Flee of Jamestown Software');
    Center(5,'2508 Valley Forge Dr., Madison WI 53719  (C)1986');
    NormVideo;
    RestoreCursor;
  End;

FUNCTION Exist(FileName : Str80) : Boolean;
  VAR
    Fil : file;
  Begin
    Assign(Fil,FileName);
    {$I-}
    Reset(Fil);
    {$I+}
    Exist := (IOResult=0);
    Close(Fil);
  End;

TYPE FieldType = (Af,Nf,Rf,Df,Yf);    { Alpha, Numeric, Real, Date, Yes/No }

PROCEDURE InputStr (VAR S : AnyStr;
                        L,X,Y : Integer;
                        FType : FieldType;
                        Term : CharSet;
                    VAR TC : Char);
  CONST
    UnderScore = '_';
  VAR
    P : Integer;
    Ch,Ch2 : Char;
    LegalChar : CharSet;
    Message : Str80;
    FirstChar : Boolean;
    EntryString : AnyStr;
    X1,X2,X3 : Integer;
    Error : Boolean;
  Begin
    Case FType of
      Af : LegalChar := [' '..'~'];             { Alpha }
      Nf : LegalChar := ['-','0'..'9'];         { Numeric }
      Rf : LegalChar := ['-','.','0'..'9'];     { Real }
      Df : LegalChar := ['/','0'..'9'];         { Date }
      Yf : LegalChar := ['Y','y','N','n'];      { Yes/No }
    End; { case }
    GotoXY(X,Y); Write(S,ConstStr(UnderScore,L-Length(S)));
    P := 0;
    FirstChar := True;
    EntryString := S;
    Repeat
      GotoXY(X+P,Y);
      Read(Kbd,Ch);
      If ((Ch in [#32..#126]) and FirstChar) and FirstCharDelete then begin
        P:=0;
        S:='';
        Write(S,ConstStr(UnderScore,L-Length(S)));
        GotoXY(X+P,Y);
      End;
      FirstChar := False;
      Case Ch of
        #32..#126 : If (P<L) and (Ch in LegalChar) then
                    Begin
                      If FType = Yf then begin
                        Case Ch of
                          'Y','y' : S := 'Yes';
                          'N','n' : S := 'No ';
                        End;
                        P:=0;
                        GotoXY(X+P,Y);
                        Write(S,ConstStr(UnderScore,L-Length(S)));
                        Ch := #13;
                      End Else begin
                        If Length(S)=L then Delete(S,L,1);
                        P := P+1;
                        Insert(Ch,S,P);
                        Write(Copy(S,P,L));
                      End;
                    End
                    Else Beep;
               ^H : If P>0 then
                    Begin
                      Delete(S,P,1);
                      Write(^H,Copy(S,P,L),UnderScore);
                      P := P-1;
                    End
                    Else Beep;
              #27 : If KeyPressed then Begin
                      Read(Kbd,Ch2);
                      Case Ch2 of

                      { Func. Codes: F1=59 F2=60 F3=61 ... F10=68 }

                      #59 : Ch := ^Q;
                      #62 : Begin
                              P:=0;
                              S:='';
                              GotoXY(X+P,Y);
                              Write(S,ConstStr(UnderScore,L-Length(S)));
                            End;
                      #66 : Begin
                              FirstCharDelete := NOT FirstCharDelete;
                              Ch := #13;
                            End;
                      #68 : Ch := ^Z;

                      { Keypad Codes:  71 72 73
                                       75 76 77
                                       79 80 81
                                    -82- -83-    }

                      #75 : If P>0 then P := P-1
                            Else Beep;
                      #77 : If P<Length(S) then P := P+1
                            Else Beep;
                      #79 : P := Length(S);
                      #71 : P := 0;
                      #72 : Ch := ^E;
                      #80 : Ch := ^X;
                      #83 : If P<Length(S) then
                            Begin
                              Delete(S,P+1,1);
                              Write(Copy(S,P+1,L),UnderScore);
                            End;
                      End; {case}
                    End Else Begin
                      S := EntryString;
                      P:=0;
                      GotoXY(X+P,Y);
                      Write(S,ConstStr(UnderScore,L-Length(S)));
                      Ch := #13;
                    End; {begin}
      End; {case}
      If (Ch in Term) and (FType = Df) then begin
        Error := False;
        Val(Copy(S,1,2),X3,X2);
        If X2<>0 then Error := True;
        Val(Copy(S,4,2),X1,X2);
        If X2=0 then
          Case X1 of
            4,6,9,11        : If NOT (X3 in [1..30]) then Error := True;
            1,3,5,7,8,10,12 : If NOT (X3 in [1..31]) then Error := True;
            2               : If NOT (X3 in [1..29]) then Error := True
           Else Error := True;
        End Else Error := True;
        Val(Copy(S,7,2),X1,X2);
        If X2<>0 then Error := True;
        If X2=0 then If X1<85 then Error := True;
        If Error then begin
          Beep;
          P:=0;
          S:=EntryString;
          GotoXY(X+P,Y);
          Write(S,ConstStr(UnderScore,L-Length(S)));
          Ch := #0;
          FirstChar := True;
        End;
      End;
    Until Ch in Term;
    P := Length(S);
    GotoXY(X+P,Y); Write('':L-P);
    TC := Ch;
  End;

PROCEDURE QuickSortRecord(VAR Item:EA; Count:Integer);
  PROCEDURE QuickSort(SBegin,SCount:Integer;VAR It:EA);
    VAR I,J:Integer;
        X1,X2:E;
    Begin
      I:=SBegin;
      J:=SCount;
      X1:=It[(SBegin+SCount) div 2];
      Repeat
        While (It[I].EName+It[I].EExt) < (X1.EName+X1.EExt) do I:=I+1;
        While (X1.EName+X1.EExt) < (It[J].EName+It[J].EExt) do J:=J-1;
        If I<=J then begin
          X2:=Entry[I];
          Entry[I]:=Entry[J];
          Entry[J]:=X2;
          I:=I+1;
          J:=J-1;
        End;
      Until I>J;
      If SBegin<J then QuickSort(SBegin,J,It);
      If SBegin<SCount then QuickSort(I,SCount,It);
    End; { procedure QuickSort }
    Begin
      QuickSort(1,Count,Item);
    End;  { procedure QuickSortRecord }